Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue66/SQLComp/DMSQLBase.pas

Pascal/Delphi Source File | 2000-09-20 | 18.7 KB | 607 lines

unit DMSQLBase;

{
  Features not implemented for simplicity:
  - Support for the UNION clause.
  - Criteria on HAVING clause.
  - Definition of a set of valid operators for each criterion (currently it is
    possible to create senseless combinations).
}

interface

uses
  Classes, DB;

type
  // Supported SQL operators.
  TSQLOperator = (opEqualTo, opGreaterThan, opLessThan, opGreaterThanOrEqualTo,
    opLessThanOrEqualTo, opNotEqualTo, opBeginningWith, opEndingWith,
    opContaining);

  // Criterion options.
  // sqlOverrideFieldType: if this option is set, the component employs the
  //   value of the DataType property in building the SQL string; otherwise
  //   the data type is determined by going up the DataSource/DataField chain
  //   to the Field object (this works only if persistent fields are defined).
  // sqlAddBrackets: the criterion is enclosed in round brackets.
  TSQLCriterionOption = (sqlOverrideFieldType, sqlAddBrackets);
  TSQLCriterionOptions = set of TSQLCriterionOption;

const
  SQLCriterionOptionsDefault = [sqlOverrideFieldType, sqlAddBrackets];

type
  // Options for the query component.
  // sqlOpenAfterBuild: the query is opened after each BuildSQL call.
  TSQLOption = (sqlOpenAfterBuild);
  TSQLOptions = set of TSQLOption;

const
  SQLOptionsDefault = [];

type
  // Operator for the connection of criteria.
  TSQLConnector = (scAnd, scOr);

const
  SQLConnectorDefault = scAnd;

type
  // Every criterion component must implement this interface.
  IDMSQLCriterion = interface
    ['{8967F222-FD6F-11D3-BA36-CA3BD3000000}']
    // Returns the complete SQL expression relative to the criterion.
    function GetSQL: string;
    // Clears the criterion.
    procedure ClearSQL;
  end;

  // Used by a TDMSQLCriterion object to read information from the
  // owning object.
  IDMSQLCriterionData = interface
    ['{8967F223-FD6F-11D3-BA36-CA3BD3000000}']
    // Returns the value(s) of the criterion; Unassigned means no chosen
    // criterion.
    function GetSQLValue: Variant;
  end;

  // A component may delegate the implementation of IDMSQLCriterion to an
  // object of this class or of a derived one.
  TDMSQLCustomCriterion = class(TPersistent)
  private
    FOwner: IDMSQLCriterionData;
    FDataSource: TDataSource;
    FDataField: string;
    FDataType: TFieldType;
    FSQLOperator: TSQLOperator;
    FSQLOptions: TSQLCriterionOptions;
  protected
    function GetOpeningBracket: string;
    function GetClosingBracket: string;
    function GetDataSource: TDataSource; virtual;
    function GetDataField: string; virtual;
    function GetDataType: TFieldType; virtual;
    function GetSQLOperator: TSQLOperator; virtual;
    function GetSQLOptions: TSQLCriterionOptions; virtual;
    procedure SetSQLOperator(Value: TSQLOperator); virtual;
    procedure SetDataType(const Value: TFieldType); virtual;
    function EncodeSQLOpValue(AOperator: TSQLOperator; AValue: Variant;
      ADataType: TFieldType): string;
    function EncodeSQLValue(AValue: Variant; ADataType: TFieldType;
      AddBefore: string = ''; AddAfter: string = ''): string;
    // Builds the SQL string from the parameters.
    // AValue indicates the field value; Null means a NULL value, Unassigned
    // an unspecified value (which will produce a Result of '').
    function BuildSQL(AFieldName: string; ADataType: TFieldType;
      AOperator: TSQLOperator; AValue: Variant): string; virtual; abstract;
    property DataSource: TDataSource read GetDataSource write FDataSource;
    property DataField: string read GetDataField write FDataField;
    property DataType: TFieldType read GetDataType write SetDataType
      default ftString;
    property SQLOperator: TSQLOperator read GetSQLOperator write SetSQLOperator
      default opEqualTo;
    property SQLOptions: TSQLCriterionOptions read GetSQLOptions write FSQLOptions
      default SQLCriterionOptionsDefault;
  public
    constructor Create(AOwner: IDMSQLCriterionData);
    // Builds and returns the SQL string for the owning criterion.
    function GetSQL: string;
    procedure CustomNotification(AComponent: TComponent; Operation: TOperation);
  published
  end;

  // A single criterion (f. ex. for a TEdit).
  TDMSQLSingleCriterion = class(TDMSQLCustomCriterion)
  protected
    function BuildSQL(AFieldName: string; ADataType: TFieldType;
      AOperator: TSQLOperator; AValue: Variant): string; override;
  published
    property DataSource;
    property DataField;
    property DataType;
    property SQLOperator;
    property SQLOptions;
  end;

  // A multi-select criterion (f. ex. for a TListBox).
  TDMSQLMultipleCriterion = class(TDMSQLCustomCriterion)
  protected
    function BuildSQL(AFieldName: string; ADataType: TFieldType;
      AOperator: TSQLOperator; AValue: Variant): string; override;
  published
    property DataSource;
    property DataField;
    property DataType;
    property SQLOptions;
  end;

  // Used for BuildSQL; the parameters are a reference to an object implementing
  // the IDMSQLCriterion interface plus a flag that indicates whether the
  // callback procedure must be called again or not.
  TDMSQLCriteriaEnumProc = procedure (var Criterion: IDMSQLCriterion; var IsLast: Boolean) of object;

  TDMSQLQueryImpl = class;

  // Identifies a query object in our framework.
  IDMSQLQuery = interface
    ['{ABE29522-FDD0-11D3-BA36-CA3BD3000000}']
    // These two methods are called by the TDMSQLQueryImpl object before and
    // after each call to BuildSQL.
    procedure BeforeBuild(Sender: TDMSQLQueryImpl);
    procedure AfterBuild(Sender: TDMSQLQueryImpl);
    // This method is called by the TDMSQLQueryImpl after a BuildSQL (and before
    // AfterBuild) to set the newly built SQL statement. Usually, a query object
    // will assign the value to its SQL property.
    procedure SetSQLText(Value: string);
  end;

  TDMSQLQueryImpl = class(TPersistent)
  private
    FOwner: IDMSQLQuery;
    FBaseSQL: TStrings;
    FBuiltSQL: TStrings;
    FSQLOptions: TSQLOptions;
    FSQLConnector: TSQLConnector;
    procedure DoAfterBuild;
    procedure DoBeforeBuild;
    procedure AddCriterion(Value: IDMSQLCriterion);
    procedure ClearCriterion(Value: IDMSQLCriterion);
    function GetSQLOptions: TSQLOptions;
    procedure SetSQLConnector(const Value: TSQLConnector);
    procedure SetBaseSQL(const Value: TStrings);
    procedure MergeBuiltSQL;
    procedure PurgeAddedCriteria(SQLText: TStrings);
    function GetSQLConnectorAsString: string;
  public
    constructor Create(AOwner: IDMSQLQuery);
    destructor Destroy; override;
    // The base SQL statement; this property must be assigned a value at least
    // once by the query object (f. ex. in the Loaded method).
    property BaseSQL: TStrings read FBaseSQL write SetBaseSQL;
    // Methods to build the SQL string from:
    // - an array of criteria.
    procedure BuildSQL(Criteria: array of IDMSQLCriterion); overload;
    // - all the criteria owned by AOwner.
    procedure BuildSQL(AOwner: TComponent); overload;
    // - all the criteria passed by the callback function.
    procedure BuildSQL(EnumProc: TDMSQLCriteriaEnumProc); overload;
    // Methods to clear the criteria.
    procedure ClearCriteria(Criteria: array of IDMSQLCriterion); overload;
    procedure ClearCriteria(AOwner: TComponent); overload;
    procedure ClearCriteria(EnumProc: TDMSQLCriteriaEnumProc); overload;
  published
    property SQLOptions: TSQLOptions read GetSQLOptions write FSQLOptions
      default SQLOptionsDefault;
    property SQLConnector: TSQLConnector read FSQLConnector write SetSQLConnector
      default SQLConnectorDefault;
  end;

const
  // Not all the data types are supported for applying a filter.
  SupportedDataTypes = [ftString, ftSmallint, ftInteger, ftWord, ftFloat,
    ftCurrency, ftBCD, ftDate, ftTime, ftDateTime, ftAutoInc, ftFixedChar,
    ftWideString, ftLargeint];

var
  SQLQuote: Char = '''';

implementation

uses
  SysUtils, DMSQLUtils;

{ TDMSQLCustomCriterion }

constructor TDMSQLCustomCriterion.Create(AOwner: IDMSQLCriterionData);
begin
  inherited Create;
  FOwner := AOwner;
  FSQLOperator := opEqualTo;
  FDataType := ftString;
  FSQLOptions := SQLCriterionOptionsDefault;
end;

function TDMSQLCustomCriterion.GetSQL: string;
var
  TheField: TField;
begin
  Result := '';
  if GetDataField() <> '' then begin
    if sqlOverrideFieldType in GetSQLOptions() then
      Result := BuildSQL(GetDataField(), GetDataType(), GetSQLOperator(), FOwner.GetSQLValue())
    else begin
      if (GetDataSource() <> nil) and (GetDataSource().DataSet <> nil) then begin
        TheField := GetDataSource().DataSet.FindField(GetDataField());
        if TheField <> nil then
          Result := BuildSQL(TheField.FieldName, TheField.DataType, GetSQLOperator(), FOwner.GetSQLValue());
      end;
    end;
  end;
end;

function TDMSQLCustomCriterion.EncodeSQLOpValue(AOperator: TSQLOperator; AValue: Variant; ADataType: TFieldType): string;
begin
  case AOperator of
    opEqualTo: Result := '= ' + EncodeSQLValue(AValue, ADataType);
    opGreaterThan: Result := '> ' + EncodeSQLValue(AValue, ADataType);
    opLessThan: Result := '< ' + EncodeSQLValue(AValue, ADataType);
    opGreaterThanOrEqualTo: Result := '>= ' + EncodeSQLValue(AValue, ADataType);
    opLessThanOrEqualTo: Result := '<= ' + EncodeSQLValue(AValue, ADataType);
    opNotEqualTo: Result := '<> ' + EncodeSQLValue(AValue, ADataType);
    opBeginningWith: Result := 'like ' + EncodeSQLValue(AValue, ADataType, '', '%');
    opEndingWith: Result := 'like ' + EncodeSQLValue(AValue, ADataType, '%', '');
    opContaining: Result := 'like ' + EncodeSQLValue(AValue, ADataType, '%', '%');
  end;
end;

function TDMSQLCustomCriterion.EncodeSQLValue(AValue: Variant; ADataType: TFieldType;
  AddBefore: string = ''; AddAfter: string = ''): string;
begin
  Result := '';
  case ADataType of
    ftString, ftFixedChar, ftWideString: begin
      Result := SQLQuote + AddBefore + AValue + AddAfter + SQLQuote;
    end;
    ftSmallint, ftInteger, ftWord, ftAutoInc, ftLargeint: begin
      Result := AValue;
    end;
    ftFloat, ftCurrency, ftBCD: begin
      Result := AValue;
    end;
    ftDate, ftTime, ftDateTime: begin
      Result := SQLQuote + FormatSQLDateTime(StrToDateTime(AValue)) + SQLQuote;
    end;
  end;
end;

function TDMSQLCustomCriterion.GetOpeningBracket: string;
begin
  if sqlAddBrackets in GetSQLOptions() then
    Result := '('
  else
    Result := '';
end;

function TDMSQLCustomCriterion.GetClosingBracket: string;
begin
  if sqlAddBrackets in GetSQLOptions() then
    Result := ')'
  else
    Result := '';
end;

function TDMSQLCustomCriterion.GetDataField: string;
begin
  Result := FDataField;
end;

procedure TDMSQLCustomCriterion.SetSQLOperator(Value: TSQLOperator);
begin
  if FSQLOperator <> Value then
    FSQLOperator := Value;
end;

function TDMSQLCustomCriterion.GetDataSource: TDataSource;
begin
  Result := FDataSource;
end;

function TDMSQLCustomCriterion.GetDataType: TFieldType;
begin
  Result := FDataType;
end;

function TDMSQLCustomCriterion.GetSQLOptions: TSQLCriterionOptions;
begin
  Result := FSQLOptions;
end;

function TDMSQLCustomCriterion.GetSQLOperator: TSQLOperator;
begin
  Result := FSQLOperator;
end;

procedure TDMSQLCustomCriterion.SetDataType(const Value: TFieldType);
begin
  if not (Value in SupportedDataTypes) then
    raise Exception.Create('Field type not supported');
  if FDataType <> Value then
    FDataType := Value;
end;

procedure TDMSQLCustomCriterion.CustomNotification(AComponent: TComponent; Operation: TOperation);
begin
  if Operation in [opRemove] then begin
    if AComponent = FDataSource then
      FDataSource := nil;
  end;
end;

{ TDMSQLSingleCriterion }

function TDMSQLSingleCriterion.BuildSQL(AFieldName: string;
  ADataType: TFieldType; AOperator: TSQLOperator; AValue: Variant): string;
begin
  if VarIsEmpty(AValue) then
    // Unassigned
    Result := ''
  else if AValue = Null then begin
    // Null
    if AOperator = opEqualTo then
      Result := GetOpeningBracket() + AFieldName + ' is null' + GetClosingBracket()
    else
      Result := GetOpeningBracket() + AFieldName + 'is not null' + GetClosingBracket();
  end
  else begin
    // Other values
    if ADataType in SupportedDataTypes then
      Result := GetOpeningBracket() + AFieldName + ' ' +
        EncodeSQLOpValue(AOperator, AValue, ADataType) + GetClosingBracket();
  end;
end;

{ TDMSQLMultipleCriterion }

function TDMSQLMultipleCriterion.BuildSQL(AFieldName: string;
  ADataType: TFieldType; AOperator: TSQLOperator; AValue: Variant): string;
var
  g: Integer;
  CurrValue: Variant;
  HighBound: Integer;
  CurrStr: string;
begin
  if VarIsEmpty(AValue) then
    // Unassigned
    Result := ''
  else if VarIsArray(AValue) then begin
    HighBound := VarArrayHighBound(AValue, 1);
    for g := VarArrayLowBound(AValue, 1) to HighBound do begin
      CurrStr := '';
      CurrValue := AValue[g];
      if VarIsEmpty(CurrValue) then
        Result := ''
      else if CurrValue = Null then
        // Null
        CurrStr := GetOpeningBracket() + AFieldName + ' is null' + GetClosingBracket()
      else begin
        // Other values
        if ADataType in SupportedDataTypes then
          CurrStr := GetOpeningBracket() + AFieldName + ' ' +
            EncodeSQLOpValue(AOperator, CurrValue, ADataType) + GetClosingBracket();
      end;
      if CurrStr <> '' then begin
        Result := Result + CurrStr;
        if g < HighBound then
          Result := Result + ' or ';
      end;
    end;
    if Result <> '' then
      Result := GetOpeningBracket() + Result + GetClosingBracket();
  end;
end;

{ TDMSQLQueryImpl }

constructor TDMSQLQueryImpl.Create(AOwner: IDMSQLQuery);
begin
  inherited Create;
  FOwner := AOwner;
  FSQLOptions := SQLOptionsDefault;
  FSQLConnector := SQLConnectorDefault;
  FBaseSQL := TStringList.Create;
  FBuiltSQL := TStringList.Create;
end;

destructor TDMSQLQueryImpl.Destroy;
begin
  FBaseSQL.Free;
  FBuiltSQL.Free;
  inherited;
end;

procedure TDMSQLQueryImpl.BuildSQL(Criteria: array of IDMSQLCriterion);
var
  g: Integer;
begin
  DoBeforeBuild;
  for g := Low(Criteria) to High(Criteria) do
    AddCriterion(Criteria[g]);
  DoAfterBuild;
end;

procedure TDMSQLQueryImpl.BuildSQL(AOwner: TComponent);
var
  g: Integer;
  CurrentCriterion: IDMSQLCriterion;
begin
  if Assigned(AOwner) then begin
    DoBeforeBuild;
    for g := 0 to Pred(AOwner.ComponentCount) do
      if AOwner.Components[g].GetInterface(IDMSQLCriterion, CurrentCriterion) then
        AddCriterion(CurrentCriterion);
    DoAfterBuild;
  end;
end;

procedure TDMSQLQueryImpl.BuildSQL(EnumProc: TDMSQLCriteriaEnumProc);
var
  Finished: Boolean;
  CurrentCriterion: IDMSQLCriterion;
begin
  if Assigned(EnumProc) then begin
    DoBeforeBuild;
    Finished := False;
    repeat
      CurrentCriterion := nil;
      EnumProc(CurrentCriterion, Finished);
      if Assigned(CurrentCriterion) then
        AddCriterion(CurrentCriterion);
    until Finished;
    DoAfterBuild;
  end;
end;

procedure TDMSQLQueryImpl.ClearCriteria(Criteria: array of IDMSQLCriterion);
var
  g: Integer;
begin
  for g := Low(Criteria) to High(Criteria) do
    ClearCriterion(Criteria[g]);
end;

procedure TDMSQLQueryImpl.ClearCriteria(AOwner: TComponent);
var
  g: Integer;
  CurrentCriterion: IDMSQLCriterion;
begin
  if Assigned(AOwner) then begin
    for g := 0 to Pred(AOwner.ComponentCount) do
      if AOwner.Components[g].GetInterface(IDMSQLCriterion, CurrentCriterion) then
        ClearCriterion(CurrentCriterion);
  end;
end;

procedure TDMSQLQueryImpl.ClearCriteria(EnumProc: TDMSQLCriteriaEnumProc);
var
  Finished: Boolean;
  CurrentCriterion: IDMSQLCriterion;
begin
  if Assigned(EnumProc) then begin
    Finished := False;
    repeat
      CurrentCriterion := nil;
      EnumProc(CurrentCriterion, Finished);
      if Assigned(CurrentCriterion) then
        ClearCriterion(CurrentCriterion);
    until Finished;
  end;
end;

function TDMSQLQueryImpl.GetSQLConnectorAsString: string;
begin
  Result := '';
  case FSQLConnector of
    scAnd: Result := 'and';
    scOr: Result := 'or';
  end;
end;

procedure TDMSQLQueryImpl.DoBeforeBuild;
begin
  FBuiltSQL.Clear;
  if Assigned(FOwner) then
    FOwner.BeforeBuild(Self);
end;

procedure TDMSQLQueryImpl.DoAfterBuild;
begin
  MergeBuiltSQL;
  if Assigned(FOwner) then
    FOwner.AfterBuild(Self);
end;

function TDMSQLQueryImpl.GetSQLOptions: TSQLOptions;
begin
  Result := FSQLOptions;
end;

procedure TDMSQLQueryImpl.SetBaseSQL(const Value: TStrings);
begin
  FBaseSQL.Assign(Value);
end;

procedure TDMSQLQueryImpl.SetSQLConnector(const Value: TSQLConnector);
begin
  if FSQLConnector <> Value then
    FSQLConnector := Value;
end;

procedure TDMSQLQueryImpl.AddCriterion(Value: IDMSQLCriterion);
var
  CriterionSQL: string;
begin
  CriterionSQL := Value.GetSQL();
  if CriterionSQL <> '' then
    FBuiltSQL.Add(CriterionSQL + ' ' + GetSQLConnectorAsString());
end;

procedure TDMSQLQueryImpl.ClearCriterion(Value: IDMSQLCriterion);
begin
  Value.ClearSQL;
end;

procedure TDMSQLQueryImpl.PurgeAddedCriteria(SQLText: TStrings);
var
  P: Integer;
  S: string;
  SQLConnStr: string;
  N: Integer;
begin
  SQLConnStr := ' ' + GetSQLConnectorAsString();
  N := SQLText.Count;
  if N > 0 then begin
    S := SQLText[Pred(N)];
    if S <> '' then begin
      P := Pos(SQLConnStr, S);
      if P = Length(S) - (Length(SQLConnStr) - 1) then begin
        System.Delete(S, P, Length(SQLConnStr));
        SQLText[Pred(N)] := S;
      end;
    end;
  end;
end;

procedure TDMSQLQueryImpl.MergeBuiltSQL;
var
  P: Integer;
begin
  // Delete the extra connector from FBuiltSQL.
  PurgeAddedCriteria(FBuiltSQL);
  // FBuiltSQL contains the list, in SQL syntax, of the where expressions
  // to add. FBaseSQL contains the basic statement.

  // If the basic statement already contains a WHERE clause, don't add one.
  if FBuiltSQL.Count > 0 then begin
    if ExtractWhereClause(FBaseSQL.Text) = '' then
      FBuiltSQL.Insert(0, sqlWhere)
    else
      FBuiltSQL.Insert(0, 'and');
  end;

  // Insert the criteria at the right place in the basic SQL string.
  // ORDER BY and GROUP BY are supported; UNION is not.
  P := InsensitivePos(sqlGroupBy, FBaseSQL.Text);
  if P <> 0 then
    FOwner.SetSQLText(MergeStr(FBuiltSQL.Text + ' ', FBaseSQL.Text, P))
  else begin
    P := InsensitivePos(sqlOrderBy, FBaseSQL.Text);
    if P <> 0 then
      FOwner.SetSQLText(MergeStr(FBuiltSQL.Text + ' ', FBaseSQL.Text, P))
    else
      FOwner.SetSQLText(FBaseSQL.Text + ' ' + FBuiltSQL.Text);
  end;
end;

end.